perm filename INVERT.LSP[W78,JMC] blob sn#343578 filedate 1978-03-22 generic text, type T, neo UTF8

(DEFUN INVERT (PAT EXP ALISTS) 
       (COND ((NULL ALISTS) NIL)
	     (T (APPEND (INVERT1 PAT EXP (CAR ALISTS))
			(INVERT PAT EXP (CDR ALISTS)))))) 

(DEFUN INVERT1 (PAT EXP ALIST) 
       (COND ((OR (NULL PAT) (EQ PAT T) (NUMBERP PAT))
	      (COND ((EQUAL PAT EXP) (LIST ALIST)) (T NIL)))
	     ((ATOM PAT)
	      ((LAMBDA (Z) (COND ((NULL Z)
				  (LIST (CONS (CONS PAT EXP) ALIST)))
				 ((EQUAL (CDR Z) EXP) (LIST ALIST))
				 (T NIL)))
	       (ASSOC PAT ALIST)))
	     ((EQ (CAR PAT) 'QUOTE)
	      (COND ((EQUAL (CADR PAT) EXP) (LIST ALIST)) (T NIL)))
	     ((EQ (CAR PAT) 'CONS)
	      (COND ((ATOM EXP) NIL)
		    (T (INVERT (CADDR PAT)
			       (CDR EXP)
			       (INVERT (CADR PAT)
				       (CAR EXP)
				       (LIST ALIST))))))
	     ((EQ (CAR PAT) 'LIST)
	      (INVERT1 (COND ((NULL (CDR PAT)) 'NIL)
			     (T (LIST 'CONS
				      (CADR PAT)
				      (CONS 'LIST
					    (CDDR PAT)))))
		       EXP
		       ALIST))
	     ((EQ (CAR PAT) 'APPEND)
	      (MAPAPPEND (FUNCTION (LAMBDA (Z) 
					   (INVERT1 (CONS 'LIST
							  (CDR PAT))
						    Z
						    ALIST)))
			 (SEGMENTS EXP (LENGTH (CDR PAT))))))) 

(DEFUN MAPAPPEND (F U) 
       (COND ((NULL U) NIL)
	     (T (APPEND (F (CAR U)) (MAPAPPEND F (CDR U)))))) 

(DEFUN SPLIT (U) 
       (CONS (LIST NIL U)
	     (COND ((NULL U) NIL)
		   (T (MAPCAR (FUNCTION (LAMBDA (Z) 
						(CONS (CONS (CAR U)
							    (CAR Z))
						      (CDR Z))))
			      (SPLIT (CDR U))))))) 

(DEFUN SEGMENTS (U N) 
       (COND
	((EQUAL N 1.) (LIST (LIST U)))
	(T
	 (MAPAPPEND
	  (FUNCTION
	   (LAMBDA (W) (MAPCAR (FUNCTION (LAMBDA (Z) 
						 (APPEND Z (CDR W))))
			       (SPLIT (CAR W)))))
	  (SEGMENTS U (SUB1 N))))))